#' Partial function application
#'
#' Partially applies a variable number of arguments to a given function.
#'
#' @param fn A function.
#' @param ... Arguments to be applied.
#'
#' @examples
#' x <- c(1, 2, NA, 4)
#' f <- partial(mean, na.rm = TRUE)
#' f(x)
#'
#' @export
partial <- function(fn, ...) {
    dots <- list(...)

    force(fn)
    function(...) do.call(fn, c(dots, list(...)))
}

#' Evaluate an expression with substitution
#'
#' \code{evalMacro} takes an unevaluated expression and an environment
#' to first substitute the specified objects and then evaluate the
#' resulting expression. The function \code{\link{bquote}} is used for
#' substitution, see the help page for substitution syntax.
#'
#' @param expr Expression
#' @param env Environment used for substitution.
#'
#' @details We use \code{\link{bquote}} instead of
#'     \code{\link{substitute}} to force an explicit syntax
#'     highlighting which objects should be substituted. The resulting
#'     expression is then evaluated within the context of the parent
#'     environment (see: \code{\link{parent.frame}}).
#'
#' @examples
#' x <- 1
#' expr <- quote(.(a) + 1)
#'
#' evalMacro(expr, list(a = x))
#'
#' df <- data.frame(x = c(1, 2, 3))
#' transform(df, y = evalMacro(expr, list(a = x)))
#'
#' @export
evalMacro <- function(expr, env = parent.frame()) {
    x <- do.call(bquote, list(expr, env))
    eval(x, parent.frame())
}


#' Remove new line characters
#'
#' Replaces new line characters in a character vector with a blank space
#'
#' @param v A character vector
#'
#' @examples
#' v = c("Mr. Smith \\n goes home")
#' rm_newline(v)
#'
#' @export
rm_newline <- function(v) {
    gsub("\r|\n", " ", v) %>% trimws
}

#' Swap single comma deliminated strings
#'
#' \code{comma_swap} is meant to transform comma deliminated country
#' names like "Korea, South" to their canonical name, "South Korea".
#'
#' @param v \code{CharacterVector}
#'
#' @section Warning: \code{comma_swap} assumes only a single comma in
#'     each string and will issue an error if there aren't exactly two
#'     elements after splitting on ','.
#'
#' @return \code{CharacterVector}
#'
#' @examples
#' comma_swap(c("Korea, South", "Korea, North"))
#'
#' @export
comma_swap <- function(v) {
    idx <- grepl(",", v)
    v[idx] <- strsplit(v[idx], ",") %>%
        lapply(function(n) {
            if (length(n) != 2)
                stop("Invalid number of commas in string")

            rev(n) %>% paste(collapse = " ") %>% trimws
        }) %>% unlist

    v
}

#' Use .pgpass file for postgres login
#'
#' Reads login credentials from a pgpass file and returns a list of
#' named vectors for each entry.
#'
#' @param pass_file Location of pgpass file. Default: ~/.pgpass.
#' @param ... Named regular expressions used to filter entries from
#'     ~/.pgpass. Names must correspond to one or more of "host",
#'     "port", "dbname", "user", "password".
#'
#' @examples
#' pg_pass()
#' pg_pass(host = "example-host", user = "example-user")
#'
#' @export
pg_pass <- function(pass_file = file.path(Sys.getenv("HOME"), ".pgpass"), ...) {
    # If HOME is unset file.path will return "/.pgpass"
    if (!dir.exists(Sys.getenv("HOME")) | !file.exists(pass_file)) {
        warning("Unable to find pass_file")
        return(NULL)
    }

    lines <- try(readLines(pass_file))

    if (class(lines) == "try-error")
        return(NULL)

    fields <- c("host", "port", "dbname", "user", "password")
    ll <- lapply(lines, function(l) {
        stats::setNames(strsplit(l, ":")[[1]], fields)
    })

    if (length(ll) == 0)
        return(NULL)

    args <- list(...)

    if (length(args) > 0) {
        unknown <- names(args)[!names(args) %in% fields]
        if (length(unknown) > 0)
            sprintf("Unknown fields: %s", paste(unknown, collapse = ",")) %>% stop

        out.ll <- Filter(function(l) {
            # Lexical scoping!!
            f <- function(s) grepl(args[[s]], l[[s]])
            all(vapply(names(args), f, logical(1)))
        }, ll)

        if (length(out.ll) == 0) NULL else out.ll
    } else {
        ll
    }
}

#' Connect to the V-Dem DB
#'
#' Convenience function meant to connect directly to the V-Dem
#' Postgres Database. Calls \code{\link{pg_pass}} with the default
#' location of \code{pass_file}, which should include all connection
#' details. For more fine grain control, \code{\link{pg_pass}} should
#' be used directly, or alternatively if a \code{.pgpass} entry is
#' missing, \code{\link[DBI]{dbConnect}}, \code{\link[DBI]{dbDriver}},
#' and \code{\link[RPostgres]{Postgres}}.
#'
#' @return Returns an object of class \code{PostgreSQLConnection}.
#'
#' @export
pg_connect <- function(dbname = "vdem_data") {
    if (!requireNamespace("RPostgreSQL", quietly = T))
        stop("Missing package: RPostgreSQL", call. = F)

    creds <- pg_pass(dbname = dbname)[[1]]
    creds <- creds[names(creds) != "dbname"]

    do.call(DBI::dbConnect, c(drv = RPostgreSQL::PostgreSQL(),
                              dbname = dbname,
                              creds))
}

#' Ordinalize numeric vector
#'
#' Ordinalize an interval scaled numeric vector based on
#' automatic equal-spaced intervals.
#'
#' @param v NumericVector
#' @param categories Desired number of ordinal categories
#' @param max Maximum of \code{v} scale
#' @param min Minimum of \code{v} scale
#' @param vec Bins passed to \code{\link{findInterval}}
#' @param ... Additional arguments passed to \code{ordinalize}
#'
#' @details \code{ordinalize} should not be confused with the
#'     \code{\link{ord}} function. The latter ordinalizes the MM
#'     output using an ordinal scale transformation to map back to the
#'     original ordinal answer categories. The former simply splits up
#'     a numeric vector into equal intervals and assigns the given
#'     number of categories.
#'
#'     Note, ordinalization is is done using left-open intervals. For
#'     example, the lowest category from the default \code{ord_5C}
#'     output is 0 corresponding to \code{N <= .2}, the second is 1
#'     for values \code{.2 < N <= .5}, and etc etc.
#'
#' @section \code{ord_3C}:
#'     The \code{ord_3C} by default operates slightly different from the
#'     other convenience functions. Rather than being a balanced
#'     ordinalization (\emph{i.e.,} equally spaced bins determining
#'     membership in each category), \code{ord_3C} passes in a \code{vec}
#'     of \code{c(0, .25, .5, 1)}. The rationale is that 3 category
#'     versions of indices are meant to represent "Autocratic" (0 -
#'     .25), "Electoral Authoritarian" (.25 - .5), and "Minimally
#'     Democratic" (.5 - 1).
#'
#'
#' @examples
#' (v <- runif(5))
#'
#' ordinalize(v, categories = 5)
#' ord_5C(v)
#'
#' ord_4C(v)
#' ordinalize(v, categories = 4)
#'
#' # Note the difference b/w output
#' ordinalize(v, categories = 3)
#' ord_3C(v)
#'
#' @export
ordinalize <- function(v, categories, max = 1, min = 0,
               vec = seq(min, max, by = max / categories)) {
    if (min(v, na.rm = T) < min | max(v, na.rm = T) > max)
        stop("Out of bounds vector elements", call. = F)

    x <- findInterval(v, vec = vec, left.open = T, all.inside = T)

    (x - 1) / (categories - 1)
}

#' @describeIn ordinalize Ordinalize to 3 categories according to
#'     V-Dem rules. See the section, Details.
#' @export
ord_3C <- function(...) {
    Call <- match.call(expand.dots = T)

    if (is.null(Call[["vec"]])) {
        scale_max <- Call[["max"]] %||% 1
        scale_min <- Call[["min"]] %||% 0

        vec <- c(scale_min,
                .25 * (scale_max - scale_min),
                2 * (.25 * (scale_max - scale_min)),
                scale_max)

        ordinalize(categories = 3, vec = vec, ...)
    } else
        ordinalize(categories = 3, ...)
}

#' @describeIn ordinalize Ordinalize to 4 categories
#' @export
ord_4C <- function(...) ordinalize(categories = 4, ...)

#' @describeIn ordinalize Ordinalize to 5 categories
#' @export
ord_5C <- function(...) ordinalize(categories = 5, ...)


#' Check if arguments are \code{identical}
#'
#' Given an initial function argument, \code{all_identical} loops
#' through the remaining arguments checking that they are
#' \code{\link{identical}}.
#'
#' @param ... Objects to check
#'
#' @return A single boolean indicating whether all of the provided
#'     arguments are identical to each other.
#'
#' @examples
#' all_identical(list("a", "b"), list("a", "b"))
#'
#' all_identical("Not", "Equal")
#'
#' @export
all_identical <- function(...) {
    if (missing(...))
        stop("Missing arguments", call. = F)

    args <- list(...)

    if (length(args) < 2)
        return(TRUE)

    bools <- logical(length(args) - 1)
    for (i in 2:length(args))
        bools[i - 1] <- identical(args[[1]], args[[i]])

    all(bools)
}

#' Set union for variable number of arguments
#'
#' \code{s_union} returns the unique elements from a set
#' \code{\link{union}} between all function arguments.
#'
#' @param ... Variable number of arguments of any type.
#'
#' @section Warning: The resulting output object will not inherit the
#'     user-defined attributes of the input objects.
#'
#'     Also, as a further note, input objects are expected to be of
#'     the same type and are therefore exposed to R's normal system of
#'     type coercion.
#'
#' @examples
#' s_union(letters[1:3], letters[2:4], letters[3:5])
#'
#' @export
s_union <- function(...) {
    if (missing(...))
        stop("Missing arguments", call. = F)

    args <- list(...)

    if (length(args) < 2)
        return(args[[1]])

    unique(do.call(c, args))
}
